home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / vectors.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-06-18  |  6.5 KB  |  284 lines
  1. /* ******************************************************************** */
  2. /*  vector.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: vectors.c,v 1.5 1992/06/16 19:31:54 pab Exp $
  9.  *
  10.  * $Log: vectors.c,v $
  11.  * Revision 1.5  1992/06/16  19:31:54  pab
  12.  * added primitive operations
  13.  *
  14.  * Revision 1.4  1992/01/09  22:29:12  pab
  15.  * Fixed for low tag ints
  16.  *
  17.  * Revision 1.3  1991/12/22  15:14:46  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.2  1991/09/11  12:07:52  pab
  21.  * 11/9/91 First Alpha release of modified system
  22.  *
  23.  * Revision 1.1  1991/08/12  16:50:13  pab
  24.  * Initial revision
  25.  *
  26.  * Revision 1.3  1991/02/13  18:27:11  kjp
  27.  * Pass.
  28.  *
  29.  */
  30.  
  31. #define KJPDBG(x) 
  32.  
  33. /*
  34.  * Change Log:
  35.  *   Version 1, October 1989
  36.  *   Hacked everything - not robust ( even slightly ) (24/10/89) KJP
  37.  *   Properly + GC protect (hopefully) 
  38.  *
  39.  *   Garbage checked - OK.
  40.  */
  41.  
  42. #include <stdio.h>
  43. #include "funcalls.h"
  44. #include "defs.h"
  45. #include "structs.h"
  46. #include "global.h"
  47. #include "error.h"
  48. #include "bootstrap.h"
  49.  
  50. /* Modulise: allocation */
  51.  
  52. #include "modboot.h"
  53.  
  54. #define VECTORS_ENTRIES 11
  55.  
  56. MODULE     Module_vectors;
  57. LispObject Module_vectors_values[VECTORS_ENTRIES];
  58.  
  59. static LispObject maximum_vector_index;
  60.  
  61. /* End Modulise: allocation*/
  62.  
  63.  
  64. EUFUN_1( Fn_vectorp, obj)
  65. {
  66.   return((typeof(obj) == TYPE_VECTOR?lisptrue:nil));
  67. }
  68. EUFUN_CLOSE
  69.  
  70. EUFUN_2( Fn_make_vector, n, obj)
  71. {
  72.   LispObject vector;
  73.   int i;
  74.  
  75.   while (!is_fixnum(n)) 
  76.     n = CallError(stacktop,
  77.           "Non-integer vector length in 'make-vector'",n,CONTINUABLE);
  78.  
  79.   if (intval(n) < 0)
  80.     CallError(stacktop,
  81.           "Non-positive vector length in 'make-vector'",n,NONCONTINUABLE);
  82.  
  83. /*
  84.   if (intval(n) == 0) return(nil);
  85. */
  86.  
  87.   if (intval(n) > intval(maximum_vector_index))
  88.     CallError(stacktop,
  89.           "Vector length in 'make-vector' too large",n,NONCONTINUABLE);
  90.  
  91.   /* For the moment using object as an initialisation argument */
  92.  
  93.   vector = (LispObject) allocate_vector(stacktop,intval(n));
  94.  
  95.   obj = ARG_1(stackbase);
  96.   for (i = 0; i < intval(n); ++i) vrefupdate(vector,i,obj);
  97.  
  98.   return(vector);
  99. }
  100. EUFUN_CLOSE
  101.  
  102. EUFUN_2( Fn_make_vector_optional, n, args)
  103. {
  104.   return(EUCALL_2(Fn_make_vector,n,(args == nil ? nil : CAR(args))));
  105. }
  106. EUFUN_CLOSE
  107.  
  108. EUFUN_1( Fn_vector_length, vect)
  109. {
  110.   LispObject len;
  111.  
  112.   while (!is_vector(vect))
  113.     vect = CallError(stacktop,
  114.              "Non-vector in 'vector-length'",vect,CONTINUABLE);
  115.  
  116.   len = (LispObject) allocate_integer(stacktop,vect->VECTOR.length);
  117.   
  118.   return(len);
  119. }
  120. EUFUN_CLOSE
  121.  
  122. EUFUN_2( Fn_vector_ref, vect, n)
  123. {
  124.   while (!is_vector(vect))
  125.     vect = CallError(stacktop,
  126.              "Non-vector in 'vector-ref'", vect, CONTINUABLE);
  127.  
  128.   while (!is_fixnum(n))
  129.     vect = CallError(stacktop,
  130.              "Non-integer in 'vector-ref'",
  131.              ARG_1(stackbase), CONTINUABLE );
  132.  
  133.   n = ARG_1(stackbase);
  134.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  135.     CallError(stacktop,"Index out of range in 'vector-ref'",n,NONCONTINUABLE);
  136.   
  137.   return(vref(vect,intval(n)));
  138. }
  139. EUFUN_CLOSE
  140.  
  141. EUFUN_3( Fn_vector_ref_updator, vect, n, obj)
  142. {
  143.   while (!is_vector(vect))
  144.     vect = CallError(stacktop,
  145.              "Non-vector in 'vector-ref-updator'", vect, CONTINUABLE);
  146.  
  147.   while (!is_fixnum(n))
  148.     vect = CallError(stacktop,
  149.              "Non-integer in 'vector-ref-updator'",
  150.              ARG_1(stackbase), CONTINUABLE );
  151.  
  152.   n = ARG_1(stackbase);
  153.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  154.     CallError(stacktop,
  155.           "Index out of range in 'vector-ref-updator'",n,NONCONTINUABLE);
  156.  
  157.   vect = ARG_0(stackbase);
  158.   obj = ARG_2(stackbase);
  159.   vrefupdate(vect,intval(n),obj);
  160.  
  161.   return(obj);
  162. }
  163. EUFUN_CLOSE
  164.  
  165. EUFUN_1( Fn_vector, forms)
  166. {
  167.   LispObject vect;
  168.   int i, vlen;
  169.  
  170. /*
  171.   if (forms == nil)
  172.     CallError("Can't make zero length vector in 'vector'",nil,NONCONTINUABLE);
  173. */
  174.  
  175.   EUCALLSET_1(vect, Fn_length, forms);
  176.   vlen = intval(vect);
  177.   vect = (LispObject) allocate_vector(stacktop,vlen);
  178.  
  179.   forms = ARG_0(stackbase);
  180.   for (i = 0; i < vlen; ++i) {
  181.     vrefupdate(vect,i,CAR(forms));
  182.     forms = CDR( forms );
  183.   }
  184.  
  185.   return(vect);
  186. }
  187. EUFUN_CLOSE
  188.  
  189. /* This should just be a method to 'convert' when it exists */
  190.  
  191. EUFUN_1( Fn_convert_vector_list, vect )
  192. {
  193.   LispObject newlist;
  194.   int i;
  195.  
  196.   while (!is_vector(vect)) {
  197.     vect = CallError(stacktop,
  198.              "Non-vector in vector coercion", vect, CONTINUABLE );
  199.   }
  200.  
  201.   newlist = nil;
  202.   for ( i = vect->VECTOR.length; i > 0; --i ) {
  203.     ARG_0(stackbase) = vect;
  204.     EUCALLSET_2(newlist, Fn_cons, vref( vect, i-1 ), newlist );
  205.     vect = ARG_0(stackbase);
  206.   }
  207.  
  208.   return( newlist );
  209. }
  210. EUFUN_CLOSE
  211.  
  212. EUFUN_2(Fn_make_primitive_object, class, size)
  213. {
  214.   LispObject tmp;
  215.  
  216.   tmp=allocate_vector(stacktop,intval(size));
  217.   lval_classof(tmp)=class;
  218.   
  219.   return tmp;
  220.  
  221. }
  222. EUFUN_CLOSE
  223.  
  224. EUFUN_2(Fn_primitive_ref, o, n)
  225. {
  226.   return vref(o,intval(n));
  227. }
  228. EUFUN_CLOSE
  229.  
  230. EUFUN_3(Fn_primitive_ref_setter, o, n ,v)
  231. {
  232.   vref(o,intval(n))=v;
  233.   
  234.   return v;
  235.  
  236. }
  237. EUFUN_CLOSE
  238.  
  239. /* Generic prin... */
  240.  
  241. EUFUN_2( Md_generic_prin_Vector, vect, str)
  242. {
  243.   if (!is_stream(str))
  244.     CallError(stacktop,"generic-prin: non-stream argument",str,NONCONTINUABLE);
  245.  
  246.   fprintf(str->STREAM.handle,"#V(something)");
  247.  
  248.   return(vect);
  249. }
  250. EUFUN_CLOSE
  251.  
  252. void initialise_vectors(LispObject* stacktop)
  253. {
  254.   LispObject getter, setter;
  255.  
  256.   /* Modulise: initialisation */
  257.  
  258.   open_module(stacktop,
  259.           &Module_vectors,Module_vectors_values,"vectors",VECTORS_ENTRIES);
  260.  
  261.   (void) make_module_function(stacktop,"vectorp",Fn_vectorp,1);
  262.   (void) make_module_function(stacktop,
  263.                   "make-vector",Fn_make_vector_optional,-2);
  264.   (void) make_module_function(stacktop,"vector-length",Fn_vector_length,1);
  265.   getter = make_module_function(stacktop,"vector-ref",Fn_vector_ref,2);
  266.   STACK_TMP(getter);
  267.   setter = make_module_function(stacktop,
  268.                 "vector-ref-updator",Fn_vector_ref_updator,3);
  269.   UNSTACK_TMP(getter);
  270.   set_anon_associate(stacktop,getter,setter);
  271.   (void) make_module_function(stacktop,"make-initialized-vector",Fn_vector,-1);
  272.   (void) make_module_function(stacktop,
  273.                   "convert-vector-list",Fn_convert_vector_list,1);
  274.   maximum_vector_index = allocate_integer(stacktop,0xfffff);
  275.   add_root(&maximum_vector_index);
  276.  
  277.   (void) make_module_entry(stacktop,"*maximum-vector-index*",maximum_vector_index);
  278.  
  279.   (void) make_module_function(stacktop,"make-primitive-object",Fn_make_primitive_object,3);
  280.   (void) make_module_function(stacktop,"primitive-ref",Fn_primitive_ref,2);
  281.   (void) make_module_function(stacktop,"set-primitive-ref",Fn_primitive_ref_setter,3);
  282.   close_module();
  283. }
  284.